{********************************************************}
{                                                        }
{                 Zeos Database Objects                  }
{               Lexical Sql-Scanner class                }
{                                                        }
{       Copyright (c) 1999-2001 Sergey Seroukhov         }
{    Copyright (c) 1999-2002 Zeos Development Group      }
{                                                        }
{********************************************************}

unit ZSqlScanner;

interface

uses Classes, SysUtils, ZScanner, ZSqlTypes;

type
  { Abstract Sql-scanner class definition }
  TZZSqlScanner = class (TZZScanner)
  protected
    FDatabaseType: TDatabaseType;

    function LowRunLex(var CurrPos, CurrLineNo: Integer;
      var CurrToken: string): Integer; override;

    function InnerProcSqlComment(var CurrPos, CurrLineNo: Integer;
      var CurrToken: string): Integer; virtual;
    function InnerProcSqlString(var CurrPos, CurrLineNo: Integer;
      var CurrToken: string): Integer; virtual;
    function InnerProcSqlIdent(var CurrPos, CurrLineNo: Integer;
      var CurrToken: string): Integer; virtual;
    function InnerProcSqlDelim(var CurrPos, CurrLineNo: Integer;
      var CurrToken: string): Integer; virtual;
  public
    constructor Create; override;

    function WrapString(Value: string): string; override;
    function UnwrapString(Value: string): string; override;

    function ExtractSpaces: string;
    function ExtractStatement(var CurrPos, CurrLen, CurrLineNo: Integer): string;

    property DatabaseType: TDatabaseType read FDatabaseType;
  end;

  { Interbase Scanner }
  TZZIbSqlScanner = class (TZZSqlScanner)
  public
    constructor Create; override;
  end;

  { MS SQL Scanner }
  TZZMsSqlScanner = class (TZZSqlScanner)
  protected
    function InnerProcSqlComment(var CurrPos, CurrLineNo: Integer;
      var CurrToken: string): Integer; override;
  public
    constructor Create; override;
  end;

  { Oracle Scanner }
  TZZOraSqlScanner = class (TZZSqlScanner)
  public
    constructor Create; override;
  end;

  { PostgreSql Scanner }
  TZZPgSqlScanner = class (TZZSqlScanner)
  protected
    function InnerProcSqlComment(var CurrPos, CurrLineNo: Integer;
      var CurrToken: string): Integer; override;
    function InnerProcSqlString(var CurrPos, CurrLineNo: Integer;
      var CurrToken: string): Integer; override;
  public
    constructor Create; override;
    function WrapString(Value: string): string; override;
    function UnwrapString(Value: string): string; override;
  end;

  { MySql Scanner }
  TZZMySqlScanner = class (TZZSqlScanner)
  protected
    function InnerProcSqlComment(var CurrPos, CurrLineNo: Integer;
      var CurrToken: string): Integer; override;
    function InnerProcSqlString(var CurrPos, CurrLineNo: Integer;
      var CurrToken: string): Integer; override;
  public
    constructor Create; override;
    function WrapString(Value: string): string; override;
    function UnwrapString(Value: string): string; override;
  end;

{ Create a Sql scanner according DatabaseType }
function CreateSqlScanner(DatabaseType: TDatabaseType): TZZSqlScanner;

implementation

{*********************** General constants ************************}
const
  MaxSqlKeyword  = 24;
  SqlKeyword: array[1..MaxSqlKeyword] of string =
  (
    'select','update','delete','create','drop','explain','from','where',
    'order','by','group','having','set','values','into','union','all',
    'distinct','left','right','on','join','outer','inner'
  );

{***********************  General routines ***********************}
{ Create a Sql scanner according DatabaseType }
function CreateSqlScanner(DatabaseType: TDatabaseType): TZZSqlScanner;
begin
  case DatabaseType of
    dtMySql:      Result := TZZMySqlScanner.Create;
    dtInterbase:  Result := TZZIbSqlScanner.Create;
    dtMsSql:      Result := TZZMsSqlScanner.Create;
    dtPostgreSql: Result := TZZPgSqlScanner.Create;
    dtOracle:     Result := TZZOraSqlScanner.Create;
    else          Result := TZZMySqlScanner.Create;
  end;
end;

{ TZZSqlScanner }

{ Class constructor }
constructor TZZSqlScanner.Create;
begin
  inherited Create;
  FDatabaseType := dtUnknown;
end;

{ Unconvert value into pascal-like strings }
function TZZSqlScanner.UnwrapString(Value: string): string;
var
  Pos, Len: Integer;
begin
  Result := '';
  if Value = '' then Exit;
  Pos := 1;
  Delete(Value, 1, 1);
  Len := Length(Value);
  while Pos <= Len do
  begin
    if not (Value[Pos] in ['''', '"']) then
      Result := Result + Value[Pos]
    else if (Pos < Len) and (Value[Pos+1] = Value[Pos]) then
    begin
      Result := Result + Value[Pos];
      Inc(Pos);
    end;
    Inc(Pos);
  end;
end;

{ Convert string value into pascal-like string }
function TZZSqlScanner.WrapString(Value: string): string;
var
  Pos: Integer;
begin
  Result := '''';
  for Pos := 1 to Length(Value) do
  begin
    Result := Result + Value[Pos];
    if Value[Pos] = '''' then
      Result := Result + Value[Pos];
  end;
  Result := Result + '''';
end;

{ Get lowlevel token }
function TZZSqlScanner.LowRunLex(var CurrPos, CurrLineNo: Integer;
  var CurrToken: string): Integer;
begin
  { Initialize the lexing }
  Result := InnerStartLex(CurrPos, CurrLineNo, CurrToken);

  if Result <> tokUnknown then Exit;

  { Process sql comments }
  Result := InnerProcSqlComment(CurrPos, CurrLineNo, CurrToken);
  if Result <> tokUnknown then Exit;

  { Look for sql delimiters }
  Result := InnerProcSqlDelim(CurrPos, CurrLineNo, CurrToken);
  if Result <> tokUnknown then Exit;

  { Look for sql string }
  Result := InnerProcSqlString(CurrPos, CurrLineNo, CurrToken);
  if Result <> tokUnknown then Exit;

  { Look for identifiers and constants }
  Result := InnerProcSqlIdent(CurrPos, CurrLineNo, CurrToken);
end;

{ Extract leading whitespaces }
function TZZSqlScanner.ExtractSpaces: string;
begin
  Result := '';
  if FBufferPos > FBufferLen then Exit;
  { Skip whitespaces }
  // ELITE Changes!!! for bug 463862  // added 10/4/2001 mjd
  while (FBufferPos <= FBufferLen)
    and (FBuffer[FBufferPos] in [' ',#9,#10]) do
  // while (FBuffer[FBufferPos] in [' ',#9,#10]) AND
  // (FBufferPos <= FBufferLen) do
  begin
    Result := Result + FBuffer[FBufferPos];
    Inc(FBufferPos);
  end;
end;

{ Extract an Sql statement }
function TZZSqlScanner.ExtractStatement(var CurrPos, CurrLen,
  CurrLineNo: Integer): string;
var
  Token: string;
  TokenType, TokenLineNo, TokenPos: Integer;
begin
  ExtractSpaces;
  CurrPos := FBufferPos; // Added
  CurrLineNo := FBufferLine;
  Result := '';
  TokenType := RunLex(TokenPos, TokenLineNo, Token);
  while TokenType in [tokEol, tokLF] do
    TokenType := RunLex(TokenPos, TokenLineNo, Token);
//  CurrPos := TokenPos - 1;
  while (TokenType <> tokEof) and (Token <> ';') do
  begin
    { Handling LF chars  (#10) }
    if (TokenType=tokLF) and not (Result[Length(Result)] in [' ', #9]) then
      Result := Result + ' '
    else
      Result := Result + Token;
    Token := ExtractSpaces;
    if Token <> '' then
      Result := Result + ' ';
    TokenType := RunLex(TokenPos, TokenLineNo, Token);
  end;
  CurrLen := FBufferPos - CurrPos; // -1;
  if ShowComment and ShowEol then
    Result := AdjustLineBreaks(Result);
end;

{********************** Lexical procedures *********************}

{ Process sql delimiters }
function TZZSqlScanner.InnerProcSqlDelim(var CurrPos, CurrLineNo: Integer;
  var CurrToken: string): Integer;
var
  Temp, Temp1: Char;
begin
  Result := tokUnknown;
  Temp := CurrToken[1];
  { Check for brace }
  if Temp in ['{', '}', '(', ')', '[', ']'] then
  begin
    Result := tokBrace;
  end
  { Check for separator }
  else if Temp in [',', ';', ':'] then
  begin
    Result := tokSeparator;
  end
  { Check for delimiters }
  else if Pos(Temp, '~!#%?|=+-<>/*^@#') > 0 then
  begin
    Result := tokOperator;
    if FBufferPos <= FBufferLen then
      Temp1 := FBuffer[FBufferPos]
    else Temp1 := #0;
    if ((Temp = '>') and (Temp1 = '='))
      or ((Temp = '<') and (Temp1 in ['=', '>'])) then
    begin
      CurrToken := CurrToken + Temp1;
      Inc(FBufferPos);
    end;
  end;
end;

{ Process sql comments }
function TZZSqlScanner.InnerProcSqlComment(var CurrPos, CurrLineNo: Integer;
  var CurrToken: string): Integer;
begin
  { Check for single-line comment }
  if (CurrToken[1] = '/') and (FBufferPos <= FBufferLen)
    and (FBuffer[FBufferPos] = '/') then
  begin
    Result := InnerProcLineComment(CurrPos, CurrLineNo, CurrToken);
    Exit;
  end;
  { Check for multi-line comment }
  Result := InnerProcCComment(CurrPos, CurrLineNo, CurrToken);
end;

{ Process sql strings }
function TZZSqlScanner.InnerProcSqlString(var CurrPos, CurrLineNo: Integer;
  var CurrToken: string): Integer;
begin
  Result := InnerProcPasString(CurrPos, CurrLineNo, CurrToken);
end;

{ Process sql identifiers and constants }
function TZZSqlScanner.InnerProcSqlIdent(var CurrPos, CurrLineNo: Integer;
  var CurrToken: string): Integer;
var
  I: Integer;
  Search: string;
begin
  { Look for digits and identifiers }
  Result := InnerProcIdent(CurrPos, CurrLineNo, CurrToken);
  { Look for sql keywords }
  if (Result = tokIdent) and ShowKeyword then
  begin
    Search := LowerCase(CurrToken);
    for I := 1 to MaxSqlKeyword do
      if SqlKeyword[I] = Search then
      begin
        Result := tokKeyword;
        Exit;
      end;
  end;
end;

{ TZZIbSqlScanner }

{ Class constructor }
constructor TZZIbSqlScanner.Create;
begin
  inherited Create;
  FDatabaseType := dtInterbase;
end;

{ TZZMsSqlScanner }

{ Class constructor }
constructor TZZMsSqlScanner.Create;
begin
  inherited Create;
  FDatabaseType := dtMsSql;
end;

{ Process MS SQL comments }
function TZZMsSqlScanner.InnerProcSqlComment(var CurrPos,
  CurrLineNo: Integer; var CurrToken: string): Integer;
begin
  { Check for single-line comment }
  if (CurrToken[1] = '-') and (FBufferPos <= FBufferLen)
    and (FBuffer[FBufferPos] = '-') then
  begin
    Result := InnerProcLineComment(CurrPos, CurrLineNo, CurrToken);
    Exit;
  end;
  { Check for multi-line comment }
  Result := InnerProcCComment(CurrPos, CurrLineNo, CurrToken);
end;

{ TZZOraSqlScanner }

{ Class constructor }
constructor TZZOraSqlScanner.Create;
begin
  inherited Create;
  FDatabaseType := dtOracle;
end;

{ TZZMySqlScanner }

{ Class constructor }
constructor TZZMySqlScanner.Create;
begin
  inherited Create;
  FDatabaseType := dtMySql;
end;

{ Unconvert value into string value for MySql }
function TZZMySqlScanner.UnwrapString(Value: string): string;
var
  N: Integer;
  Ptr1, Ptr2: PChar;
begin
  Result := '';
  if Value = '' then Exit;
  Delete(Value, 1, 1);
  Delete(Value, Length(Value), 1);

  SetLength(Result, Length(Value)+1);
  Ptr1 := PChar(Value);
  Ptr2 := PChar(Result);
  N := 0;
  while Ptr1^ <> #0 do
  begin
    if Ptr1^ <> '\' then
      Ptr2^ := Ptr1^
    else begin
      Inc(Ptr1);
      if Ptr1 = #0 then Break;
      case Ptr1^ of
        'n': Ptr2^ := #10;
        'r': Ptr2^ := #13;
        'Z': Ptr2^ := #26;
        '0': Ptr2^ := #0;
        else Ptr2^ := Ptr1^;
      end;
    end;
    Inc(N);
    Inc(Ptr1);
    Inc(Ptr2);
  end;
  SetLength(Result, N);
end;

{ Convert string value into string for MySql }
function TZZMySqlScanner.WrapString(Value: string): string;
var
  I, Add, Len: Integer;
  Ptr: PChar;
begin
  Add := 0;
  Len := Length(Value);
  for I := 1 to Len do
    if Value[I] in ['''','"','\',#26,#10,#13,#0] then
      Inc(Add);
  SetLength(Result, Len + Add);
  Ptr := PChar(Result);
  for I := 1 to Len do
  begin
    if Value[I] in ['''','"','\',#26,#10,#13,#0] then
    begin
      Ptr^ := '\';
      Inc(Ptr);
      case Value[I] of
        #26: Ptr^ := 'Z';
        #10: Ptr^ := 'n';
        #13: Ptr^ := 'r';
        #0:  Ptr^ := '0';
        else Ptr^ := Value[I];
      end;
    end else
      Ptr^ := Value[I];
    Inc(Ptr);
  end;
  Result := '''' + Result + '''';
end;

{ Process MySql comment }
function TZZMySqlScanner.InnerProcSqlComment(var CurrPos,
  CurrLineNo: Integer; var CurrToken: string): Integer;
begin
  Result := tokUnknown;
  { Check for -- single-line comment }
  if (CurrToken[1] = '-') and (FBufferPos <= FBufferLen)
    and (FBuffer[FBufferPos] = '-') then
  begin
    Result := InnerProcLineComment(CurrPos, CurrLineNo, CurrToken);
    Exit;
  end;
  { Check for # single-line comment }
  if CurrToken[1] = '#' then
  begin
    Result := InnerProcLineComment(CurrPos, CurrLineNo, CurrToken);
    Exit;
  end;
end;

{ Process MySql strings }
function TZZMySqlScanner.InnerProcSqlString(var CurrPos,
  CurrLineNo: Integer; var CurrToken: string): Integer;
begin
  Result := InnerProcCString(CurrPos, CurrLineNo, CurrToken);
end;

{ TZZPgSqlScanner }

{ Class constructor }
constructor TZZPgSqlScanner.Create;
begin
  inherited Create;
  FDatabaseType := dtPostgreSql;
end;

{ Unconvert value into string value for PostgreSql }
function TZZPgSqlScanner.UnwrapString(Value: string): string;
var
  N: Integer;
  Ptr1, Ptr2: PChar;
begin
  Result := '';
  if Value = '' then Exit;
  Delete(Value, 1, 1);
  Delete(Value, Length(Value), 1);

  SetLength(Result, Length(Value)+1);
  Ptr1 := PChar(Value);
  Ptr2 := PChar(Result);
  N := 0;
  while Ptr1^ <> #0 do
  begin
    if Ptr1^ <> '\' then
      Ptr2^ := Ptr1^
    else begin
      Inc(Ptr1);
      if Ptr1 = #0 then Break;
      case Ptr1^ of
        'n': Ptr2^ := #10;
        'r': Ptr2^ := #13;
        't': Ptr2^ := #9;
        '0': Ptr2^ := #0;
        else Ptr2^ := Ptr1^;
      end;
    end;
    Inc(N);
    Inc(Ptr1);
    Inc(Ptr2);
  end;
  SetLength(Result, N);
end;

{ Convert string value into string for PostgreSql }
function TZZPgSqlScanner.WrapString(Value: string): string;
var
  I, Add, Len: Integer;
  Ptr: PChar;
begin
  Add := 0;
  Len := Length(Value);
  for I := 1 to Len do
    if Value[I] in ['''','"','\',#9,#10,#13,#0] then
      Inc(Add);
  SetLength(Result, Len + Add);
  Ptr := PChar(Result);
  for I := 1 to Len do
  begin
    if Value[I] in ['''','"','\',#9,#10,#13,#0] then
    begin
      Ptr^ := '\';
      Inc(Ptr);
      case Value[I] of
        #9:  Ptr^ := 't';
        #10: Ptr^ := 'n';
        #13: Ptr^ := 'r';
        #0:  Ptr^ := '0';
        else Ptr^ := Value[I];
      end;
    end else
      Ptr^ := Value[I];
    Inc(Ptr);
  end;
  Result := '''' + Result + '''';
end;

{ Process PostgreSql comment }
function TZZPgSqlScanner.InnerProcSqlComment(var CurrPos,
  CurrLineNo: Integer; var CurrToken: string): Integer;
begin
  { Check for single-line comment }
  if (CurrToken[1] = '-') and (FBufferPos <= FBufferLen)
    and (FBuffer[FBufferPos] = '-') then
  begin
    Result := InnerProcLineComment(CurrPos, CurrLineNo, CurrToken);
    Exit;
  end;
  { Check for multi-line comment }
  Result := InnerProcCComment(CurrPos, CurrLineNo, CurrToken);
end;

{ Process PostgreSql strings }
function TZZPgSqlScanner.InnerProcSqlString(var CurrPos,
  CurrLineNo: Integer; var CurrToken: string): Integer;
begin
  Result := InnerProcCString(CurrPos, CurrLineNo, CurrToken);
end;

end.
